home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 July / Macworld (1999-07).dmg / Shareware World / Info / For Developers / Mops 3.4.sea / Mops source / Module source / zCallsMod.txt < prev    next >
Text File  |  1998-09-21  |  8KB  |  358 lines
  1.  
  2. room 750000 u<
  3. [IF]
  4.     cr .( not enough dic room to compile callsMod!) cr  ABORT
  5. [THEN]
  6.  
  7. false    constant    debug?
  8.  
  9. file  INPF
  10.  
  11. : #ALIGN4    \ ( n -- n' )
  12.     3 + $ fffffffc and  ;
  13.  
  14.  
  15. true -> case_in_names?
  16.  
  17. : macConstant
  18.     [ FALSE -> CASE_IN_NAMES? ]
  19.     >in @
  20.     defined?
  21.     IF        <'> inpf u>  IF  2drop  EXIT  THEN
  22.     ELSE    drop
  23.     THEN
  24.     >in !
  25.     constant
  26. ;
  27.  
  28.  
  29. : [IF]        drop  ;
  30. : [ELSE]    ;
  31. : [THEN]    ;
  32. : [ELIF]    drop  ;
  33.  
  34.  
  35. true -> case_in_names?
  36.  
  37. : macDefined?    DEFINED? NIP  ;
  38. : macStruct        MWORD DROP  ;
  39. : macUnion        MWORD DROP    ;
  40. : macField        DROP  MWORD DROP  ;
  41. : macFiller        2DROP  ;
  42. : macEnd-struct    2DROP  ;
  43. : macEnd-union    2DROP  ;
  44. : macSynonym    MWORD DROP  MWORD DROP  ;
  45.  
  46. : and            AND  ;
  47. : or            OR   ;
  48. : xor            XOR  ;
  49. : lshift        LSHIFT  ;
  50. : rshift        RSHIFT  ;
  51. : negate        NEGATE  ;
  52. : 'type            POSTPONE 'TYPE  ;  IMMEDIATE
  53.  
  54.  
  55. FALSE -> CASE_IN_NAMES?
  56.  
  57.  
  58. string temp
  59.  
  60. : READ_INLINE  { \ loc svd svCaseFlg -- }
  61.     case_in_names? -> svCaseFlg
  62.     false -> case_in_names?
  63.     clear: temp
  64.     BEGIN
  65.         >in @  src-len  >=
  66.         IF    svCaseFlg -> case_in_names?  EXIT
  67.         THEN
  68.         hex  mword number  decimal
  69.         pad w!  pad 2 add: temp
  70.     AGAIN  ;
  71.  
  72.  
  73. false    value    register_based?
  74. 0        value    ^hndlr
  75.  
  76.  
  77.     true -> case_in_names?
  78.  
  79. : macExtern
  80.  
  81.     [ FALSE -> CASE_IN_NAMES? ]
  82.  
  83. ( result-info parm-info #parms )
  84.         { \ #parms #cells #fparms #fres mask ^PPCinfo ^68kInfo -- }
  85.  
  86.     0 -> #cells  0 -> #fparms  false -> register_based?
  87.     0 -> #fres  0 -> mask
  88.  
  89.     >in @
  90.     defined?
  91.     IF    <'> inpf u>
  92.         IF  drop                    \ drop >in - now TOS is # parms
  93.             -1 DO  2drop  LOOP        \ drop parm info, also result info
  94.             0 -> src-len            \ skip 68k inline code sequence
  95.             EXIT
  96.         THEN
  97.     ELSE    drop
  98.     THEN
  99.  
  100.     >in !
  101.     header                        \ create the new dic entry (case sensitive)
  102.     CDP -> ^hndlr
  103.     $ D000  codeW,                \ dummy handler
  104.     CDP -> ^PPCinfo  0 code, 0 codeW,
  105.                                 \ leave space for PPC info
  106.     
  107. \ #parms
  108.     -> #parms
  109. \    DP -> ^68kInfo
  110.     #parms
  111.     IF
  112. \        pad #parms n,            \ reserve space for rest of 68k parm info
  113.         #parms FOR
  114.  
  115.         (*    #bytes in next PPC parm - convert to #cells and accumulate.  If
  116.             the $ 1000 bit is set, that means it's floating point - in that
  117.             case we count up the number of floating parms (these have to
  118.             be put in the FPRs for the call), and set the corresponding mask
  119.             bit so that the corresponding GPRs will get a dummy value.  This
  120.             calling convention is a bit crazy, but we're stuck with it.
  121.             Remember as the numbers have been pushed onto the stack, we're
  122.             going from the last parm backwards.  So i in this FOR loop gives
  123.             us the real parm# starting from zero.
  124.         *)
  125.             dup $ 1000 and
  126.             IF                \ it's floating
  127.                 1 ++> #fparms
  128.                 $ FFF and  dup 4 >
  129.                 IF        mask 2 >>  $ C000 or  -> mask    \ mask 2 dummy GPRs here
  130.                 ELSE    mask 1 >>  $ 8000 or  -> mask    \ single float - mask 1 GPR
  131.                 THEN
  132.             ELSE
  133.                 mask 1 >>  -> mask                    \ normal GPR cell - no mask bit
  134.             THEN
  135.             3 +  2 >>  ++> #cells
  136.  
  137.         \ 68k parm info - here on the PPC we just drop it
  138.             drop
  139.         \    i true 68k_parm_adjust    \ check if reg-based and take care of it
  140.         \    ^68kInfo i + c!        \ store in right order in 68k info
  141.         NEXT
  142.     THEN
  143.  
  144. \ $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
  145. \ Apparently the call TEGetPoint has a bug in current PPC implementations
  146. \ - the 2 parms are required to be in r4 and r5, instead of r3 and r4!
  147. \ So here we kludge this particular call to think it takes one more
  148. \ cell than it really does.  If Apple fixes the bug, we'll need to delete
  149. \ this code.
  150.  
  151.     latest n>count  " TEGetPoint" s=
  152.     IF  1 ++> #cells  THEN
  153.     
  154. \ $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
  155.  
  156.     #cells        ^PPCinfo c!            \ store # PPC parm cells at ^PPCinfo
  157.  
  158. \ ( #68k-res-bytes #PPC-res-bytes )
  159.  
  160.     dup $ 1000 and
  161.     IF                                \ PPC result is floating - so no integer result
  162.         1 -> #fres  drop 0
  163.     ELSE                            \ otherwise there's no floating result
  164.         3 +  2 >>
  165.     THEN        ^PPCinfo 1+ c!        \ store # PPC integer result cells at ^PPCinfo+1
  166.     #fparms        ^PPCinfo 2+ c!        \  and # PPC FP parms at ^PPCinfo+2
  167.     #fres        ^PPCinfo 3 + c!        \  and # PPC FP results at ^PPCinfo+3
  168.                                     \  (must be 0 or 1)
  169.     mask        ^PPCinfo 4+  w!
  170.  
  171.     drop                            \ drop 68k result info
  172.  
  173. \    0 false 68k_parm_adjust  c,    \ store 68k info.  We don't
  174. \                                \  round here since we have to know whether
  175. \                                \  and by how much to adjust by at the end
  176. \                                \  of the call.
  177. \    align-dp
  178. \    read_inline
  179. \    reset: temp  len: temp  w,  all: temp  n,
  180.  
  181.     0 -> src-len        \ on the PPC we ignore the 68k inline code sequence
  182. ;
  183.  
  184.  
  185. : FIND_IN_CALLSMOD    \ ( s255 \ svCaseFlg -- cfa true | -- s255 false )
  186.     find: zCallsMod
  187. ;
  188.  
  189.  
  190. : myHeader
  191.     ppc_header  ;
  192.  
  193.  
  194. : KONST  { \ svCaseFlg -- konst }
  195.     case_in_names? -> svCaseFlg
  196.     true -> case_in_names?
  197.     ['] find_in_callsMod  -> extraFind
  198.     '
  199.     svCaseFlg -> case_in_names?
  200.     0 -> extraFind
  201.     dup 2- w@  $ BC02 <>  abort" not a konst!"
  202.     2+ @  postpone lit
  203. ;        immediate
  204.  
  205.  
  206. : $>KONST  { addr len \ svCaseFlg -- konst }
  207.     case_in_names? -> svCaseFlg
  208.     true -> case_in_names?
  209.     ['] find_in_callsMod  -> extraFind
  210.     addr len sFind
  211.     svCaseFlg -> case_in_names?
  212.     0 -> extraFind
  213.     NIF  abort" konst not defined"  THEN
  214.     dup 2- w@x  -4 <>  abort" not a konst!"
  215.     @
  216. ;
  217.  
  218.  
  219. (*
  220. syscall bloggs  defines "bloggs" as an system call (from the InterfaceLib
  221. or MathLib libraries).
  222.  
  223. In a definition we just put "bloggs" and it compiles a call to bloggs.  We
  224. resolve the symbol via a FindSymbol call, the first time it's called (see
  225. get_transfer_vector in Setup - a call is compiled to there as part of the
  226. external call sequence, compiled by call_extern in cg5).
  227. *)
  228.  
  229. : SYSCALL  { \    svCaseFlg sv-in addr #parms
  230.                 #parm_cells #fparms #res_cells #fres mask
  231.                 len ^len-byte  name_len -- }
  232.     ?exec
  233.     >in @  -> sv-in
  234.  
  235. \ first, is it actually a known call?
  236.  
  237.     case_in_names? -> svCaseFlg
  238.     true -> case_in_names?
  239.     ['] find_in_callsMod  -> extraFind
  240.     mword find NIF  150 die  THEN        \ "can't find call for this name"
  241.     0 -> extraFind  svCaseFlg -> case_in_names?
  242.     -> addr
  243.     addr 2- w@
  244.     dup 1 and  -> register_based?
  245.     -2 and  $ D000 <>  abort" not a call!"
  246.  
  247. \ now, if we've already defined it as a sysCall, and it's currently
  248. \  FINDable, we don't need to define it again here.
  249.  
  250.     sv-in  >in !
  251.     defined?
  252.     IF    2- w@  $ BF01 =  ?EXIT
  253.     ELSE
  254.         drop
  255.     THEN
  256.  
  257.     sv-in  >in !
  258.     myHeader  $ BF01  codeW,    \  $BF01 = handler code for sysCall
  259.  
  260.     addr c@        -> #parm_cells
  261.     addr 1+ c@    -> #res_cells
  262.     addr 2+ c@    -> #fparms
  263.     addr 3 + c@    -> #fres
  264.     addr 4+  w@ -> mask
  265.  
  266.     #parm_cells codeC,        \ 1 byte # parm cells
  267.     #res_cells codeC,        \ 1 byte # result cells
  268.     #fparms  codeC,            \ 1 byte # FP parms (in FPRs)
  269.     #fres  codeC,            \ 1 byte # FP results (in FPRs)
  270.     mask  codeW,
  271.  
  272.     DP  nilP ,                \ put nilP in data area - means not resolved yet
  273.     relocCode,                \ and reloc pointer to there in code area
  274.     0 code,                    \ for EXTERNs, lib addr goes here.  For SYSCALL,
  275.                             \  we put zero.  (This is different to 68k)
  276.     addr >name n>count dup -> name_len
  277.     CDP place                    \ and last, the case-sensitive name.
  278.     name_len 2+ #align4  ++> CDP
  279. ;
  280.  
  281.  
  282. \                =================================
  283. \                        Shared libraries
  284. \                =================================
  285.  
  286.  
  287. (*
  288.     Usage:
  289.  
  290.     LIBRARY myLib
  291.  
  292.     LIBCALL myCall { parm1 parm2 %fparm1 -- res1 }
  293.  
  294.  
  295.     The old syntax (Mops 3.2) will still be supported for a while:
  296.     
  297.     1  1 1 1 3  extern  myLib  myCall
  298.     
  299.     or for a floating routine:
  300.     
  301.     1 kFloat or  1 kFloat or  1 kFloat or  2  extern myOtherLib  myFloatGizmo
  302.  
  303.     defined as:
  304.  
  305.     EXTERN <lib_name> <call_name>
  306.             ( #result_cells #parm1_cells ... #parmN_cells N -- )
  307.  
  308. *)
  309.  
  310. : ADD_CASE_SENSITIVE_NAME
  311.     bl word
  312.     count  1+ #align4  ++> CDP
  313.     drop
  314. ;
  315.  
  316. : LIBRARY  { \    svCaseFlg sv-in addr len ^len-byte  name_len -- }
  317.     ?exec
  318.     >in @  -> sv-in        \ so we can read the name again case-sensitively
  319.  
  320. \ if we've already defined it as a library, and it's currently
  321. \  FINDable, we don't need to define it again here.
  322.  
  323.     defined?
  324.     IF    2- w@  $ BF0B =  ?EXIT
  325.     ELSE
  326.         drop
  327.     THEN
  328.  
  329.     sv-in  >in !                \ get name again for header
  330.     header  $ BF0B0000  code,    \  $BF0B = handler code for LIBRARY,
  331.                                 \   plus alignment
  332.  
  333.     DP  0 ,                        \ put 0 in data area - means no connID yet
  334.     relocCode,                    \ and reloc pointer to there in code area
  335.     
  336.     sv-in  >in !                \ now we have to get the name again, case-sensitively
  337.     add_case_sensitive_name        \  this time, and just add it to the code area.  We'll
  338.                                 \  use this when we connect to the library.
  339. ;
  340.  
  341. \                =================================
  342.  
  343.  
  344. cr
  345. cr .( Note: loading this next file will take quite a while.)
  346. cr .( A coffee break would be a good idea.)  cr
  347.  
  348. true -> case_in_names?
  349.  
  350. // xcalls
  351.  
  352. FALSE -> CASE_IN_NAMES?
  353.  
  354. release: temp
  355.  
  356. cr .( Dic room at end of compiling zCallsMod: )  room . cr
  357.  
  358.